

--------------------------------------------------------------------------------
-- |
-- Module      :  Lambola.IDL.Lexer
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Alex Lexer
--
--------------------------------------------------------------------------------

{
{-# OPTIONS -Wall #-}


module Lambola.IDL.Lexer where

import Lambola.IDL.ParseMonad
import Lambola.IDL.Token

import Control.Applicative
import Control.Monad.Identity

}



$white                  = [\ \t\v\f\r\n]

$nondigit               = [A-Za-z_]
$digit                  = 0-9
$nonzero_digit          = [1-9]
$octal_digit            = [0-7]
$hex_digit              = [0-9A-Fa-f]

$identifier_nondigit    = $nondigit
$identifier             = [$nondigit $digit]


@hex_prefix         = 0x | 0X


@integer = $digit+
@float   = $digit+ \. $digit+

idl :-

$white ;

-- Comment - cpp -E seems to fill in with lines like `# 1 "<command line>"`
<0> {
  ^\# [.]*     { skip }
  ^\/\/[.]*    { skip }
}



-- keywords

<0> {
  "any"               { keyword TK_KW_any             }
  "attribute"         { keyword TK_KW_attribute       }
  "boolean"           { keyword TK_KW_boolean         }
  "case"              { keyword TK_KW_case            }
  "char"              { keyword TK_KW_char            }
  "const"             { keyword TK_KW_const           }
  "context"           { keyword TK_KW_context         }

  "default"           { keyword TK_KW_default         }
  "double"            { keyword TK_KW_double          }
  "enum"              { keyword TK_KW_enum            }
  "exception"         { keyword TK_KW_exception       }
  "FALSE"             { keyword TK_KW_FALSE           }
  "float"             { keyword TK_KW_float           }
  "in"                { keyword TK_KW_in              }

  "inout"             { keyword TK_KW_inout           }
  "interface"         { keyword TK_KW_interface       }
  "long"              { keyword TK_KW_long            }
  "module"            { keyword TK_KW_module          }
  "Object"            { keyword TK_KW_Object          }
  "octet"             { keyword TK_KW_octet           }
  "oneway"            { keyword TK_KW_oneway          }

  "out"               { keyword TK_KW_out             }
  "raises"            { keyword TK_KW_raises          }
  "readonly"          { keyword TK_KW_readonly        }
  "sequence"          { keyword TK_KW_sequence        }
  "short"             { keyword TK_KW_short           }
  "string"            { keyword TK_KW_string          }
  "struct"            { keyword TK_KW_struct          }

  "switch"            { keyword TK_KW_switch          }
  "TRUE"              { keyword TK_KW_TRUE            }
  "typedef"           { keyword TK_KW_typedef         }
  "unsigned"          { keyword TK_KW_unsigned        }
  "union"             { keyword TK_KW_union           }
  "void"              { keyword TK_KW_void            }

}

-- identifier
<0> {
  $identifier_nondigit $identifier*     { identifier }
}

-- operators
<0> {

  \|              { operator TK_OP_bar            }
  \^              { operator TK_OP_caret          }
  \&              { operator TK_OP_ampersand      }
  "<<"            { operator TK_OP_shiftl         }
  ">>"            { operator TK_OP_shiftr         }
  \+              { operator TK_OP_plus           }
  \-              { operator TK_OP_minus          }
  \*              { operator TK_OP_mult           }
  \/              { operator TK_OP_divide         }
  \%              { operator TK_OP_modulo         }
  \~              { operator TK_OP_tilde          }

}


-- punctuators
<0> {

  \;              { punctuator TK_P_semicolon     }
  \{              { punctuator TK_P_lbrace        }
  \}              { punctuator TK_P_rbrace        }
  "::"            { punctuator TK_P_double_colon  }
  \:              { punctuator TK_P_colon         }
  \,              { punctuator TK_P_comma         }
  \=              { punctuator TK_P_equal         }
  \(              { punctuator TK_P_lparen        }
  \)              { punctuator TK_P_rparen        }
  \<              { punctuator TK_P_langle        }
  \>              { punctuator TK_P_rangle        }
  \[              { punctuator TK_P_lsquare       }
  \]              { punctuator TK_P_rsquare       }


}

-- integer constants
<0> {
  
  $nonzero_digit $digit*      { intLiteral }
  
  0 $octal_digit*             { octLiteral }
  
  @hex_prefix $hex_digit*     { hexLiteral }

} 

-- float constants
<0> { 

   @float                     { floatLiteral }
}


{

type ParseM a = ParseT Identity a

alexEOF :: (Functor m, Monad m) => ParseT m Lexeme
alexEOF = (\pos -> L pos TK_EOF) <$> getPosition



  

intLiteral :: AlexInput -> Int -> ParseM Lexeme
intLiteral = usingInput L (TK_LIT_integer . read)

-- TODO - watch out for an error on read
octLiteral :: AlexInput -> Int -> ParseM Lexeme
octLiteral = usingInput L (TK_LIT_integer . read . traf)
  where
    traf ('0':s) = '0':'o':s
    traf s       = s    -- this will probably cause a read error which is bad

hexLiteral :: AlexInput -> Int -> ParseM Lexeme
hexLiteral = usingInput L (TK_LIT_integer . read)


floatLiteral :: AlexInput -> Int -> ParseM Lexeme
floatLiteral = usingInput L (TK_LIT_floating_pt . read)




keyword :: IDLToken -> AlexInput -> Int -> ParseM Lexeme
keyword kw = usingInput L (const kw)

punctuator :: IDLToken -> AlexInput -> Int -> ParseM Lexeme
punctuator pr = usingInput L (const pr)

operator :: IDLToken -> AlexInput -> Int -> ParseM Lexeme
operator op = usingInput L (const op)


identifier :: AlexInput -> Int -> ParseM Lexeme
identifier = usingInput L TK_identifier


idlLex :: (Lexeme -> ParseM a) -> ParseM a
idlLex k = lexToken >>= k


--------------------------------------------------------------------------------
--

-- These functions are generic, but as the type AlexReturn(..) is
-- generated by Alex we can't move them into ParseMonad without a circular
-- dependency.
-- Seemingly we have to give them the most specfic type as well.

lexToken :: ParseM Lexeme
lexToken = do
    inp <- getLexerState
    case alexScan inp (start_code inp) of
      AlexEOF                     -> alexEOF
      AlexError _inp'             -> lexError "lexical error"
      AlexSkip  inp' _len         -> do
          setLexerState inp'
          lexToken
      AlexToken inp' len action   -> do 
          setLexerState inp'
          action inp len

begin :: Int -> LexerState -> Int -> ParseM Lexeme 
begin code input len = do setLexerStateStartCode code; lexToken

andBegin :: (LexerState -> Int -> ParseM Lexeme) 
                -> Int -> LexerState -> Int -> ParseM Lexeme
andBegin action code input len = do
    setLexerStateStartCode code
    action input len        


skip :: LexerState -> Int -> ParseM Lexeme 
skip _input _len = lexToken


}


